home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / inta.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  48.2 KB  |  2,250 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* interpreter procedures - interpreter part a */
  11.  
  12.  
  13. /* Include standard header modules */
  14. #include <stdio.h>
  15. #include <stdlib.h>
  16. #include "config.h"
  17. #include "int.h"
  18. #include "ivars.h"
  19. #include "farithprots.h"
  20. #include "predefprots.h"
  21. #include "machineprots.h"
  22. #include "taskingprots.h"
  23. #include "imiscprots.h"
  24. #include "intbprots.h"
  25. #include "intcprots.h"
  26. #include "intaprots.h"
  27. #ifdef vms
  28. /*
  29. #include "adaexec.h"
  30. #include descrip
  31. */
  32. #endif
  33.  
  34. static int main_loop();
  35. static int get_word();
  36. #ifdef DEBUG_INT
  37. static void zbreak(int);
  38. #endif
  39.  
  40. #define TRACE
  41. /* MAIN PROGRAM */
  42.  
  43. #ifdef DEBUG_STORES
  44. int *heap_store_addr;
  45. /* set heap_store_offset non zero to trace stores to that offset
  46.  * in primary heap 
  47.  */
  48. extern int heap_store_offset;
  49. int heap_store_now=0;
  50. #endif
  51.  
  52. int int_main()                                                /*;int_main*/
  53. {
  54.     int        status;
  55.  
  56.     reset_clock();
  57.     num_cunits = 0;
  58.  
  59.     /* Memory initialization, allocate primary heap segment. */
  60.  
  61.     if(!allocate_new_heap()) {
  62. #ifdef vms
  63.         LIB$STOP(MSG_NOHEAP);
  64. #else
  65.         fprintf(stderr,"Unable to allocate primary heap\n");
  66.         exit(RC_ABORT);
  67. #endif
  68.     }
  69.  
  70.     /* Initialize working template for fixed point arithmetic */
  71.  
  72.     *heap_next++ = 1 + WORDS_PTR + WORDS_FX_RANGE;
  73.     heap_next += WORDS_PTR;
  74.     temp_template = FX_RANGE(heap_next);
  75.     temp_template->ttype = TT_FX_RANGE;
  76.     temp_template->object_size = 2;
  77.     temp_template->small_exp_2 = 0;
  78.     temp_template->small_exp_5 = 0;
  79.     temp_template->fxlow = MIN_LONG;
  80.     temp_template->fxhigh = MAX_LONG;
  81.     heap_next += WORDS_FX_RANGE;
  82.  
  83.     /* Other initialization */
  84.  
  85.     sfp = bfp = 0;
  86.     initialize_predef();
  87.     initialize_tasking();
  88.  
  89.     /* Perform the main loop of the interpretor(terminates at end of pgm) */
  90.  
  91.     status = main_loop();
  92.  
  93.     /* Termination processing */
  94.  
  95.     predef_term();
  96.  
  97.     return status;
  98. }
  99.  
  100. /*
  101.  *  MAIN LOOP
  102.  *  =========
  103.  */
  104.  
  105. /*
  106.  *  GET_BYTE        Next code byte (char), IP is incremented
  107.  *  GET_WORD        Next code word (int), IP is incremented
  108.  *  GET_GAD(bse,off)    Get base/offset from code, IP incremented
  109.  *  GET_LAD(bse,off)    Get local addr from code, and get corr global addr
  110.  */
  111. #define GET_BYTE      (0xff & (int)cur_code[ip++])
  112. #ifdef ALIGN_WORD
  113. #define GET_WORD      (w=get_word(), w)
  114. #else
  115. #define GET_WORD          (w = *((int *)(cur_code+ip)), ip += sizeof(int), w)
  116. #endif
  117. #define GET_GAD(bse,off)  bse=GET_BYTE,off=GET_WORD
  118. #define GET_LAD(bse,off)  sp=GET_WORD+sfp,bse=cur_stack[sp],off=cur_stack[sp+1]
  119.  
  120. static int main_loop()                                            /*;main_loop*/
  121. {
  122. #ifdef DEBUG_INT
  123.     int     iparg;
  124. #endif
  125. #ifdef ALIGN_WORD
  126.     /* auxiliary procedures if must unpack from code stream byte by byte */
  127. #endif
  128. #ifdef vms
  129.     struct      dsc$descriptor_s exception_name;
  130. #endif
  131.  
  132.     /* General purpose work locations */
  133.  
  134.     /* Loop through instructions */
  135.  
  136.     for (;;) {
  137.  
  138.         /* Simulate the Clock Interrupt */
  139.  
  140.         if (next_clock_flag &&(next_clock <(now_time = itime() + time_offset)))
  141.             clock_interrupt(now_time);
  142.  
  143. #ifdef DEBUG_INT
  144. #ifdef DEBUG_STORES
  145.         if (heap_store_offset!=0 && 
  146.           heap_store_now != heap_store_addr[heap_store_offset]) {
  147.             printf("heap stores change %d from %d to %d\n",
  148.               heap_store_offset, heap_store_now, 
  149.               heap_store_addr[heap_store_offset]);
  150.             heap_store_now = heap_store_addr[heap_store_offset];
  151.         }
  152. #endif
  153.         iparg = ip;
  154.         if (instruction_trace)
  155.             i_list1(&iparg, cur_code);        /* debug */
  156.         if(break_point && (ip >= break_point))
  157.             zbreak(0);
  158. #endif
  159.         /* Get next opcode, bump instruction pointer and switch to routine */
  160.         switch(GET_BYTE) {
  161.  
  162.         case I_NOP:
  163.             break;
  164.  
  165.             /* Instructions Dealing with Tasking */
  166.  
  167.         case I_ABORT:
  168.             value = GET_WORD;            /* number of tasks in stack */
  169.             abort(value);
  170.             break;
  171.  
  172.         case I_ACTIVATE:
  173.             if (BLOCK_FRAME->bf_tasks_declared != 0) {
  174.                 value = pop_task_frame();
  175.                 start_activation(value, tp, bfp);
  176.                 /* master is current block frame */
  177.             }
  178.             break;
  179.  
  180.         case I_ACTIVATE_NEW_L:
  181.             GET_LAD(bse, off);
  182.             if (BLOCK_FRAME->bf_tasks_declared != 0) {
  183.                 value = pop_task_frame();
  184.                 ptr = ADDR(bse, off);
  185.                 start_activation(value, ACCESS(ptr)->master_task, 
  186.                   ACCESS(ptr)->master_bfp);
  187.             }
  188.             break;
  189.  
  190.         case I_ACTIVATE_NEW_G:
  191.             GET_GAD(bse, off);
  192.             if (BLOCK_FRAME->bf_tasks_declared != 0) {
  193.                 value = pop_task_frame();
  194.                 ptr = ADDR(bse, off);
  195.                 start_activation(value, ACCESS(ptr)->master_task, 
  196.                   ACCESS(ptr)->master_bfp);
  197.             }
  198.             break;
  199.  
  200.         case I_CREATE_TASK_G:
  201.             GET_GAD(bse, off);
  202.             start_creation(bse, off);
  203.             break;
  204.  
  205.         case I_CREATE_TASK_L:
  206.             GET_LAD(bse, off);
  207.             start_creation(bse, off);
  208.             break;
  209.  
  210.         case I_POP_TASKS_DECLARED_G:
  211.             GET_GAD(bse, off);
  212.             if (BLOCK_FRAME->bf_tasks_declared != 0)
  213.                 value = pop_task_frame();
  214.             else
  215.                 value = 0;
  216.             *ADDR(bse, off) = value;
  217.             break;
  218.  
  219.         case I_POP_TASKS_DECLARED_L:
  220.             GET_LAD(bse, off);
  221.             if (BLOCK_FRAME->bf_tasks_declared != 0)
  222.                 value = pop_task_frame();
  223.             else
  224.                 value = 0;
  225.             *ADDR(bse, off) = value;
  226.             break;
  227.  
  228.         case I_LINK_TASKS_DECLARED:
  229.             POP(value);
  230.             push_task_frame(value);
  231.             break;
  232.  
  233.         case I_CURRENT_TASK:
  234.             PUSH(tp);
  235.             break;
  236.  
  237.         case I_END_ACTIVATION:
  238.             value = GET_BYTE;
  239.             end_activation(value);    /* 0=error during activation, 1=ok */
  240.             break;
  241.  
  242.         case I_END_RENDEZVOUS:
  243.             end_rendezvous();
  244.             break;
  245.  
  246.         case I_ENTRY_CALL:
  247.             value = GET_WORD;        /* retrieve parameter from code */
  248.             entry_call((long) ENDLESS,value);
  249.             break;
  250.  
  251.         case I_RAISE_IN_CALLER:
  252.             raise_in_caller();
  253.             break;
  254.  
  255.         case I_SELECTIVE_WAIT:
  256.             value = GET_WORD;        /* number of alternatives */
  257.  
  258.             /* if = 0 then it is a simple accept, entry addr is on stack. */
  259.             /* else: alternative descriptors on to of stack are scanned by */
  260.             /*   the procedure, which leaves the index of the chosen one.  */
  261.  
  262.             selective_wait(value);
  263.             break;
  264.  
  265.         case I_TERMINATE:
  266.             purge_rdv(tp);
  267.             value = GET_BYTE;
  268.             deallocate(BLOCK_FRAME->bf_data_link);
  269.  
  270.             /* bf_tasks_declared always null here */
  271.  
  272.             switch(value) {
  273.  
  274.             case 0: /* task terminates because reaches the end */
  275.                 break;
  276.  
  277.             case 1: /* task terminates because of terminate alternative */
  278.                 break;
  279.  
  280.             case 2:
  281.                 value = 0;
  282.                 if (exception_trace)
  283.                     printf("task %d terminated due to unhandled exception: %s\n"
  284.                       ,tp,exception_slots[exr]);
  285.                 break;
  286.  
  287.             case 3:
  288. #ifdef vms
  289.                 exception_name.dsc$w_length = strlen(exception_slots[exr]);
  290.                 exception_name.dsc$b_dtype = DSC$K_DTYPE_T;
  291.                 exception_name.dsc$b_class = DSC$K_CLASS_S;
  292.                 exception_name.dsc$a_pointer = exception_slots[exr];
  293.                 LIB$SIGNAL(MSG_UNHANDLED,1,&exception_name);
  294.                 exit();
  295. #else
  296.                 printf("unhandled exception in library unit %s\n",
  297.                   exception_slots[exr]);
  298.                 return RC_ERRORS;
  299. #endif
  300.  
  301.             case 4:
  302. #ifdef vms
  303.                 exception_name.dsc$w_length = strlen(exception_slots[exr]);
  304.                 exception_name.dsc$b_dtype = DSC$K_DTYPE_T;
  305.                 exception_name.dsc$b_class = DSC$K_CLASS_S;
  306.                 exception_name.dsc$a_pointer = exception_slots[exr];
  307.                 LIB$SIGNAL(MSG_TERMINATE,1,&exception_name);
  308.                 exception_name.dsc$w_length = strlen(raise_reason);
  309.                 exception_name.dsc$b_dtype = DSC$K_DTYPE_T;
  310.                 exception_name.dsc$b_class = DSC$K_CLASS_S;
  311.                 exception_name.dsc$a_pointer = raise_reason;
  312.                 LIB$SIGNAL(MSG_REASON,1,&exception_name);
  313.                 exception_name.dsc$w_length = strlen(code_slots[raise_cs]);
  314.                 exception_name.dsc$b_dtype = DSC$K_DTYPE_T;
  315.                 exception_name.dsc$b_class = DSC$K_CLASS_S;
  316.                 exception_name.dsc$a_pointer = code_slots[raise_cs];
  317.                 LIB$SIGNAL(MSG_ORIGIN,1,&exception_name);
  318.                 exit();
  319. #else
  320.                 printf("main task terminated due to unhandled exception %s\n",
  321.                   exception_slots[exr]);
  322.                 printf("propagated from %s",code_slots[raise_cs]);
  323.                 if (raise_lin) printf(" at line %d",raise_lin);
  324.                 printf(" (%s)\n",raise_reason);
  325.                 return RC_ERRORS;
  326. #endif
  327.  
  328.             case 5: /* normal end of main */
  329.                 return RC_SUCCESS;
  330.  
  331.             case 6: /* dead-lock */
  332. #ifdef vms
  333.                 LIB$SIGNAL(MSG_DEADLOCK);
  334.                 exit();
  335. #else
  336.                 printf("dead-lock: system inactive\n");
  337.                 return RC_ERRORS;
  338. #endif
  339.             }
  340.             complete_task();
  341.             break;
  342.  
  343.         case I_TIMED_ENTRY_CALL:
  344.             POPL(lvalue);
  345.             /* retrieve length of parameter table from code */
  346.             entry_call((lvalue >= 0) ? lvalue : (long) 0, GET_WORD);
  347.             break;
  348.  
  349.         case I_WAIT:     /* delay */
  350.             POPL(lvalue);
  351.             delay_stmt(lvalue);
  352.             break;
  353.  
  354.             /* Instructions for Memory Allocation */
  355.  
  356.         case I_CREATE_B:
  357.         case I_CREATE_W:
  358.             create(1, &bse, &off, &ptr);
  359.             PUSH_ADDR(bse, off);
  360.             break;
  361.  
  362.         case I_CREATE_L:
  363.             create(WORDS_LONG, &bse, &off, &ptr);
  364.             PUSH_ADDR(bse, off);
  365.             break;
  366.  
  367.         case I_CREATE_A:
  368.             create(2, &bse, &off, &ptr);
  369.             PUSH_ADDR(bse, off);
  370.             break;
  371.  
  372.         case I_CREATE_STRUC:
  373.             create_structure();
  374.             break;
  375.  
  376.         case I_CREATE_COPY_STRUC:
  377.             create_copy_struc();
  378.             break;
  379.  
  380.         case I_CREATE_COPY_B:
  381.         case I_CREATE_COPY_W:
  382.             create(1, &bse, &off, &ptr);
  383.             POP(value);
  384.             PUSH_ADDR(bse, off);
  385.             *ptr = value;
  386.             break;
  387.  
  388.         case I_CREATE_COPY_L:
  389.             create(WORDS_LONG, &bse, &off, &ptr);
  390.             POPL(lvalue);
  391.             PUSH_ADDR(bse, off);
  392.             *LONG(ptr) = lvalue;
  393.             break;
  394.  
  395.         case I_CREATE_COPY_A:
  396.             create(2, &bse, &off, &ptr);
  397.             POP_ADDR(bas1, off1);
  398.             PUSH_ADDR(bse, off);
  399.             *ptr++ = bas1;
  400.             *ptr = off1;
  401.             break;
  402.  
  403.         case I_DECLARE_B:
  404.         case I_DECLARE_W:
  405.             create(1, &bse, &off, &ptr);
  406.             sp = sfp + GET_WORD;
  407.             cur_stack[sp] = bse;
  408.             cur_stack[sp + 1] = off;
  409.             break;
  410.  
  411.         case I_DECLARE_D:
  412.             create(4, &bse, &off, &ptr);
  413.             sp = sfp + GET_WORD;
  414.             cur_stack[sp] = bse;
  415.             cur_stack[sp + 1] = off;
  416.             break;
  417.  
  418.         case I_DECLARE_L:
  419.             create(WORDS_LONG, &bse, &off, &ptr);
  420.             sp = sfp + GET_WORD;
  421.             cur_stack[sp] = bse;
  422.             cur_stack[sp + 1] = off;
  423.             break;
  424.  
  425.         case I_DECLARE_A:
  426.             create(2, &bse, &off, &ptr);
  427.             sp = sfp + GET_WORD;
  428.             cur_stack[sp] = bse;
  429.             cur_stack[sp + 1] = off;
  430.             break;
  431.  
  432.         case I_ALLOCATE:
  433.             allocate_new();
  434.             break;
  435.  
  436.         case I_ALLOCATE_COPY_G:
  437.             GET_GAD(bse, off);            /* addr. of the type template */
  438.             allocate_copy(bse, off);
  439.             break;
  440.  
  441.         case I_ALLOCATE_COPY_L:
  442.             GET_LAD(bse, off);            /* addr. of the type template */
  443.             allocate_copy(bse, off);
  444.             break;
  445.  
  446.         case I_UPDATE:
  447.             sp = sfp + GET_WORD;
  448.             cur_stack[sp] = TOSM(1);    /* base */
  449.             cur_stack[sp + 1] = TOS;    /* offset */
  450.             break;
  451.  
  452.         case I_UPDATE_AND_DISCARD:
  453.             sp = sfp + GET_WORD;
  454.             POP_ADDR(bse, off);
  455.             cur_stack[sp] = bse;
  456.             cur_stack[sp + 1] = off;
  457.             break;
  458.  
  459.         case I_UNCREATE:
  460.             POP_ADDR(bse, off);
  461.             ptr = ADDR(bse, off) - WORDS_PTR - 1;
  462.             *ptr = - *ptr;
  463.             break;
  464.             /* should withdraw the variable from bf_data_link TBSL */
  465.  
  466.             /* Data Transfer Instructions */
  467.  
  468.         case I_COMPARE_B:
  469.         case I_COMPARE_W:
  470.             POP(val1);
  471.             POP(val2);
  472.             value = (val1 == val2) + 2 *((val1 < val2) ? 1:0);
  473.             /* 0 1 2 for < = > */
  474.             PUSH(value);
  475.             break;
  476.  
  477.         case I_COMPARE_L:
  478.             POPL(lval1);
  479.             POPL(lval2);
  480.             value = (lval1 == lval2) + 2 *((lval1 < lval2) ? 1:0);
  481.             /* 0 1 2 for < = > */
  482.             PUSH(value);
  483.             break;
  484.  
  485.         case I_COMPARE_A:
  486.             POP_ADDR(bas1, off1);
  487.             POP_ADDR(bas2, off2);
  488.             value = (off1 == off2 && bas1 == bas2);
  489.             PUSH(value);
  490.             break;
  491.  
  492.         case I_COMPARE_ARRAYS:
  493.             compare_arrays();
  494.             break;
  495.  
  496.         case I_COMPARE_STRUC:
  497.             compare_struc();
  498.             break;
  499.  
  500.         case I_DEREF_B:
  501.         case I_DEREF_W:
  502.             POP_ADDR(bse, off);
  503.             if (bse == 255)
  504.                 raise(CONSTRAINT_ERROR, "Null access value");
  505.             else {
  506.                 value = *ADDR(bse, off);
  507.                 PUSH(value);
  508.             }
  509.             break;
  510.  
  511.         case I_DEREF_L:
  512.             POP_ADDR(bse, off);
  513.             if (bse == 255)
  514.                 raise(CONSTRAINT_ERROR, "Null access value");
  515.             else {
  516.                 lvalue = *ADDRL(bse, off);
  517.                 PUSHL(lvalue);
  518.             }
  519.             break;
  520.  
  521.         case I_DEREF_A:
  522.             POP_ADDR(bse, off);
  523.             if (bse == 255)
  524.                 raise(CONSTRAINT_ERROR, "Null access value");
  525.             else {
  526.                 value = *ADDR(bse, off);
  527.                 PUSH(value);
  528.                 value = *ADDR(bse, off + 1);
  529.                 PUSH(value);
  530.             }
  531.             break;
  532.  
  533.         case I_DEREF_D:
  534.             POP_ADDR(bse, off);
  535.             if (bse == 255)
  536.                 raise(CONSTRAINT_ERROR, "Null access value");
  537.             else {
  538.                 value = *ADDR(bse, off);
  539.                 PUSH(value);
  540.                 value = *ADDR(bse, off + 1);
  541.                 PUSH(value);
  542.                 value = *ADDR(bse, off + 2);
  543.                 PUSH(value);
  544.                 value = *ADDR(bse, off + 3);
  545.                 PUSH(value);
  546.             }
  547.             break;
  548.  
  549.         case I_DISCARD_ADDR:
  550.             value = GET_WORD;
  551.             cur_stackptr -= (2 * value);
  552.             break;
  553.  
  554.         case I_DUPLICATE_B:
  555.         case I_DUPLICATE_W:
  556.             value = TOS;
  557.             PUSH(value);
  558.             break;
  559.  
  560.         case I_DUPLICATE_L:
  561.             lvalue = TOSL;
  562.             PUSHL(lvalue);
  563.             break;
  564.  
  565.         case I_DUPLICATE_A:
  566.             POP_ADDR(bse, off);
  567.             PUSH_ADDR(bse, off);
  568.             PUSH_ADDR(bse, off);
  569.             break;
  570.  
  571.         case I_DUPLICATE_D:
  572.             value = TOSM(3);
  573.             PUSH(value);
  574.             value = TOSM(3);
  575.             PUSH(value);
  576.             value = TOSM(3);
  577.             PUSH(value);
  578.             value = TOSM(3);
  579.             PUSH(value);
  580.             break;
  581.  
  582.         case I_INDIRECT_MOVE_B:
  583.         case I_INDIRECT_MOVE_W:
  584.             POP_ADDR(bas1, off1);
  585.             POP_ADDR(bas2, off2);
  586.             if (bas1 == 255 || bas2 == 255)
  587.                 raise(CONSTRAINT_ERROR, "Null access value");
  588.             else
  589.                 *ADDR(bas2, off2) = *ADDR(bas1, off1);
  590.             break;
  591.  
  592.         case I_INDIRECT_MOVE_L:
  593.             POP_ADDR(bas1, off1);
  594.             POP_ADDR(bas2, off2);
  595.             if (bas1 == 255 || bas2 == 255)
  596.                 raise(CONSTRAINT_ERROR, "Null access value");
  597.             else
  598.                 *ADDRL(bas2, off2) = *ADDRL(bas1, off1);
  599.             break;
  600.  
  601.         case I_INDIRECT_MOVE_A:
  602.             POP_ADDR(bas1, off1);
  603.             POP_ADDR(bas2, off2);
  604.             if (bas1 == 255 || bas2 == 255)
  605.                 raise(CONSTRAINT_ERROR, "Null access value");
  606.             else {
  607.                 *ADDR(bas2, off2) = *ADDR(bas1, off1);
  608.                 *ADDR(bas2, off2 + 1) = *ADDR(bas1, off1 + 1);
  609.             }
  610.             break;
  611.  
  612.         case I_INDIRECT_POP_B_G:
  613.         case I_INDIRECT_POP_W_G:
  614.             GET_GAD(bse, off);
  615.             POP_ADDR(bas1, off1);
  616.             if (bas1 == 255)
  617.                 raise(CONSTRAINT_ERROR, "Null access value");
  618.             else
  619.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  620.             break;
  621.  
  622.         case I_INDIRECT_POP_L_G:
  623.             GET_GAD(bse, off);
  624.             POP_ADDR(bas1, off1);
  625.             if (bas1 == 255)
  626.                 raise(CONSTRAINT_ERROR, "Null access value");
  627.             else
  628.                 *ADDRL(bse, off) = *ADDRL(bas1, off1);
  629.             break;
  630.  
  631.         case I_INDIRECT_POP_A_G:
  632.             GET_GAD(bse, off);
  633.             POP_ADDR(bas1, off1);
  634.             if (bas1 == 255)
  635.                 raise(CONSTRAINT_ERROR, "Null access value");
  636.             else {
  637.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  638.                 *ADDR(bse, off + 1) = *ADDR(bas1, off1 + 1);
  639.             }
  640.             break;
  641.  
  642.         case I_INDIRECT_POP_B_L:
  643.         case I_INDIRECT_POP_W_L:
  644.             GET_LAD(bse, off);
  645.             POP_ADDR(bas1, off1);
  646.             if (bas1 == 255)
  647.                 raise(CONSTRAINT_ERROR, "Null access value");
  648.             else
  649.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  650.             break;
  651.  
  652.         case I_INDIRECT_POP_L_L:
  653.             GET_LAD(bse, off);
  654.             POP_ADDR(bas1, off1);
  655.             if (bas1 == 255)
  656.                 raise(CONSTRAINT_ERROR, "Null access value");
  657.             else
  658.                 *ADDRL(bse, off) = *ADDRL(bas1, off1);
  659.             break;
  660.  
  661.         case I_INDIRECT_POP_A_L:
  662.             GET_LAD(bse, off);
  663.             POP_ADDR(bas1, off1);
  664.             if (bas1 == 255)
  665.                 raise(CONSTRAINT_ERROR, "Null access value");
  666.             else {
  667.                 *ADDR(bse, off) = *ADDR(bas1, off1);
  668.                 *ADDR(bse, off + 1) = *ADDR(bas1, off1 + 1);
  669.             }
  670.             break;
  671.  
  672.         case I_MOVE_B:
  673.         case I_MOVE_W:
  674.             POP(value);
  675.             POP_ADDR(bse, off);
  676.             if (bse == 255)
  677.                 raise(CONSTRAINT_ERROR, "Null access value");
  678.             else 
  679.                 *ADDR(bse, off) = value;
  680.             break;
  681.  
  682.         case I_MOVE_L:
  683.             POPL(lvalue);
  684.             POP_ADDR(bse, off);
  685.             if (bse == 255)
  686.                 raise(CONSTRAINT_ERROR, "Null access value");
  687.             else 
  688.                 *ADDRL(bse, off) = lvalue;
  689.             break;
  690.  
  691.         case I_MOVE_A:
  692.             POP_ADDR(bas1, off1);
  693.             POP_ADDR(bse, off);
  694.             ptr = ADDR(bse, off);
  695.             *ptr++ = bas1;
  696.             *ptr = off1;
  697.             break;
  698.  
  699.         case I_POP_B_G:
  700.         case I_POP_W_G:
  701.             GET_GAD(bse, off);
  702.             POP(value);
  703.             *ADDR(bse, off) = value;
  704.             break;
  705.  
  706.         case I_POP_L_G:
  707.             GET_GAD(bse, off);
  708.             POPL(lvalue);
  709.             *ADDRL(bse, off) = lvalue;
  710.             break;
  711.  
  712.         case I_POP_D_G:
  713.             /* This has to be set later  TBSL:
  714.              * for the moment, we do not take care of the poped value. We
  715.              * beleive this is only being used for the evaluation of object size
  716.              */
  717.             GET_GAD(bse, off);
  718.             for (i=1; i <= 4 ; i++)
  719.                 POP (value);
  720.             break;
  721.  
  722.         case I_POP_D_L:
  723.             GET_LAD(bse, off);
  724.             for (i=1; i <= 4; i++)
  725.                 POP (value);
  726.             break;
  727.  
  728.         case I_POP_A_G:
  729.             GET_GAD(bse, off);
  730.             POP_ADDR(bas1, off1);
  731.             *ADDR(bse, off) = bas1;
  732.             *ADDR(bse, off + 1) = off1;
  733.             break;
  734.  
  735.         case I_POP_B_L:
  736.         case I_POP_W_L:
  737.             GET_LAD(bse, off);
  738.             POP(value);
  739.             *ADDR(bse, off) = value;
  740.             break;
  741.  
  742.         case I_POP_L_L:
  743.             GET_LAD(bse, off);
  744.             POPL(lvalue);
  745.             *ADDRL(bse, off) = lvalue;
  746.             break;
  747.  
  748.         case I_POP_A_L:
  749.             GET_LAD(bse, off);
  750.             POP_ADDR(bas1, off1);
  751.             *ADDR(bse, off) = bas1;
  752.             *ADDR(bse, off + 1) = off1;
  753.             break;
  754.  
  755.         case I_PUSH_B_G:
  756.         case I_PUSH_W_G:
  757.             GET_GAD(bse, off);
  758.             value = *ADDR(bse, off);
  759.             PUSH(value);
  760.             break;
  761.  
  762.         case I_PUSH_L_G:
  763.             GET_GAD(bse, off);
  764.             lvalue = *ADDRL(bse, off);
  765.             PUSHL(lvalue);
  766.             break;
  767.  
  768.         case I_PUSH_A_G:
  769.             GET_GAD(bse, off);
  770.             ptr = ADDR(bse, off);
  771.             bas1 = *ptr++;
  772.             off1 = *ptr;
  773.             PUSH_ADDR(bas1, off1);
  774.             break;
  775.  
  776.         case I_PUSH_B_L:
  777.         case I_PUSH_W_L:
  778.             GET_LAD(bse, off);
  779.             value = *ADDR(bse, off);
  780.             PUSH(value);
  781.             break;
  782.  
  783.         case I_PUSH_L_L:
  784.             GET_LAD(bse, off);
  785.             lvalue = *ADDRL(bse, off);
  786.             PUSHL(lvalue);
  787.             break;
  788.  
  789.         case I_PUSH_A_L:
  790.             GET_LAD(bse, off);
  791.             ptr = ADDR(bse, off);
  792.             bas1 = *ptr++;
  793.             off1 = *ptr;
  794.             PUSH_ADDR(bas1, off1);
  795.             break;
  796.  
  797.         case I_PUSH_EFFECTIVE_ADDRESS_G:
  798.         case I_PUSH_IMMEDIATE_A:
  799.             GET_GAD(bse, off);
  800.             PUSH_ADDR(bse, off);
  801.             break;
  802.  
  803.         case I_PUSH_EFFECTIVE_ADDRESS_L:
  804.             GET_LAD(bse, off);
  805.             PUSH_ADDR(bse, off);
  806.             break;
  807.  
  808.         case I_PUSH_IMMEDIATE_B:
  809.             PUSH(GET_WORD);
  810.             break;
  811.  
  812.         case I_PUSH_IMMEDIATE_W:
  813.             PUSH(GET_WORD);
  814.             break;
  815.  
  816.         case I_PUSH_IMMEDIATE_L:
  817. #ifdef ALIGN_WORD
  818.             lvalue = get_long(LONG(cur_code + ip));
  819. #else
  820.             lvalue = *LONG(cur_code + ip);
  821. #endif
  822.             PUSHL(lvalue);
  823.             ip += sizeof(long);
  824.             break;
  825.  
  826.             /* Floating Point Instructions */
  827.  
  828.         case I_FLOAT_ADD_L:
  829.             POPF(rval2);
  830.             POPF(rval1);
  831.             rvalue = rval1 + rval2;
  832.             if (ABS(rvalue) > ADA_MAX_REAL)
  833.                 raise(NUMERIC_ERROR, "Floating point addition overflow");
  834.             PUSHF(rvalue);
  835.             break;
  836.  
  837.         case I_FLOAT_SUB_L:
  838.             POPF(rval2);
  839.             POPF(rval1);
  840.             rvalue = rval1 - rval2;
  841.             if (ABS(rvalue) > ADA_MAX_REAL)
  842.                 raise(NUMERIC_ERROR, "Floating point subtraction overflow");
  843.             PUSHF(rvalue);
  844.             break;
  845.  
  846.         case I_FLOAT_MUL_L:
  847.             POPF(rval2);
  848.             POPF(rval1);
  849.             rvalue = rval1 * rval2;
  850.             if (ABS(rvalue) > ADA_MAX_REAL)
  851.                 raise(NUMERIC_ERROR, "Floating point multiplication overflow");
  852.             PUSHF(rvalue);
  853.             break;
  854.  
  855.         case I_FLOAT_DIV_L:
  856.             POPF(rval2);
  857.             POPF(rval1);
  858.             if (rval2 == 0.0)
  859.                 raise(NUMERIC_ERROR, "Floating point division by zero");
  860.             else {
  861.                 rvalue = rval1 / rval2;
  862.                 if (ABS(rvalue) > ADA_MAX_REAL)
  863.                     raise(NUMERIC_ERROR, "Floating point division overflow");
  864.             }
  865.             PUSHF(rvalue);
  866.             break;
  867.  
  868.         case I_FLOAT_COMPARE_L:
  869.             POPF(rval1);
  870.             POPF(rval2);
  871.             value = (rval1 == rval2) + 2 *(rval1 < rval2);
  872.             /* 0 1 2 for < = > */
  873.             PUSH(value);
  874.             break;
  875.  
  876.         case I_FLOAT_POW_L:
  877.             POP(val2);
  878.             POPF(rval1);
  879.             if (val2 == 0)
  880.                 rvalue = 1.0;                /* x ** 0 = 0.0 */
  881.             else if (rval1 == 0.0) {
  882.                 if (val2 < 0)                /* 0 ** -x = error */
  883.                     raise(NUMERIC_ERROR, "Negative power of zero");
  884.                 else
  885.                     rvalue = 0.0;/* 0 ** +x = 0.0 */
  886.             }
  887.             else {
  888.                 rvalue = rval1;
  889.                 for (i = 1; i < ABS(val2); i++) {
  890.                     rvalue = rvalue * rval1;
  891.                     if (ABS(rvalue) > ADA_MAX_REAL) {
  892.                         if (val2 > 0) {
  893.                             /* the exception has to be raised only if the
  894.                              * exponent is positive. If it is negative, the
  895.                              * result will converge towards 0
  896.                              */
  897.                             raise(NUMERIC_ERROR, "Exponentiation");
  898.                             break;
  899.                         }
  900.                         else { 
  901.                             rvalue = 0.0; 
  902.                             val2 = 1;
  903.                             break ; 
  904.                         }
  905.                     }
  906.                 }
  907.                 if (val2 < 0)
  908.                     rvalue = 1.0 / rvalue;
  909.             }
  910.             PUSHF(rvalue);
  911.             break;
  912.  
  913.         case I_FLOAT_NEG_L:
  914.             POPF(rval1);
  915.             rvalue = -rval1;
  916.             PUSHF(rvalue);
  917.             break;
  918.  
  919.         case I_FLOAT_ABS_L:
  920.             POPF(rval1);
  921.             rvalue = ABS(rval1);
  922.             PUSHF(rvalue);
  923.             break;
  924.  
  925.             /* Logical and Arithmetic Instructions */
  926.  
  927.         case I_ADD_B:
  928.             POP(val2);
  929.             POP(val1);
  930.             value = val1 + val2;
  931.             if (value < -128 || value > 127)
  932.                 raise(NUMERIC_ERROR, "Overflow");
  933.             else
  934.                 PUSH(value);
  935.             break;
  936.  
  937.         case I_ADD_W:
  938.             POP(val2);
  939.             POP(val1);
  940.             value = word_add(val1, val2, &overflow);
  941.             if (overflow)
  942.                 raise(NUMERIC_ERROR, "Overflow");
  943.             else
  944.                 PUSH(value);
  945.             break;
  946.  
  947.         case I_ADD_L:
  948.             POPL(lval2);
  949.             POPL(lval1);
  950.             lvalue = long_add(lval1, lval2, &overflow);
  951.             if (overflow)
  952.                 raise(NUMERIC_ERROR, "Overflow");
  953.             else
  954.                 PUSHL(lvalue);
  955.             break;
  956.  
  957.         case I_ADD_IMMEDIATE_B:
  958.             POP(val1);
  959.             val2 = GET_WORD;
  960.             value = val1 + val2;
  961.             if (value < -128 || value > 127)
  962.                 raise(NUMERIC_ERROR, "Overflow");
  963.             else
  964.                 PUSH(value);
  965.             break;
  966.  
  967.         case I_ADD_IMMEDIATE_W:
  968.             POP(val1);
  969.             val2 = GET_WORD;
  970.             value = word_add(val1, val2, &overflow);
  971.             if (overflow)
  972.                 raise(NUMERIC_ERROR, "Overflow");
  973.             PUSH(value);
  974.             break;
  975.  
  976.         case I_ADD_IMMEDIATE_L:
  977.             POPL(lval1);
  978. #ifdef ALIGN_WORD
  979.             lval2 = get_long(LONG(cur_code + ip));
  980. #else
  981.             lval2 = *(LONG(cur_code + ip));
  982. #endif
  983.             ip += WORDS_LONG;
  984.             lvalue = long_add(lval1, lval2, &overflow);
  985.             if (overflow)
  986.                 raise(NUMERIC_ERROR, "Overflow");
  987.             PUSHL(lvalue);
  988.             break;
  989.  
  990.         case I_DIV_B:
  991.             POP(val2);
  992.             POP(val1);
  993.             if (val2 == 0)
  994.                 raise(NUMERIC_ERROR, "Division by zero");
  995.             else if (val1 == -128 && val2 == -1)
  996.                 raise(NUMERIC_ERROR, "Overflow");
  997.             else {
  998.                 value = val1 / val2;
  999.                 PUSH(value);
  1000.             }
  1001.             break;
  1002.  
  1003.         case I_DIV_W:
  1004.             POP(val2);
  1005.             POP(val1);
  1006.             if (val2 == 0)
  1007.                 raise(NUMERIC_ERROR, "Division by zero");
  1008.             else if (val1 == MIN_INTEGER && val2 == -1)
  1009.                 raise(NUMERIC_ERROR, "Overflow");
  1010.             else {
  1011.                 value = val1 / val2;
  1012.                 PUSH(value);
  1013.             }
  1014.             break;
  1015.  
  1016.         case I_DIV_L:
  1017.             POPL(lval2);
  1018.             POPL(lval1);
  1019.             if (lval2 == 0)
  1020.                 raise(NUMERIC_ERROR, "Division by zero");
  1021.             else if (lval1 == MIN_LONG && lval2 == -1)
  1022.                 raise(NUMERIC_ERROR, "Overflow");
  1023.             else {
  1024.                 lvalue = lval1 / lval2;
  1025.                 PUSHL(lvalue);
  1026.             }
  1027.             break;
  1028.  
  1029.         case I_REM_B:
  1030.         case I_REM_W:
  1031.             /*
  1032.              * Remainder Operation
  1033.              * -------------------
  1034.              * 
  1035.              * The modification has been done in order to prevent complex
  1036.              * calculation. The remonder operator of Ada is equivallent to "%"
  1037.              * of C. The modification is straightfoward.
  1038.              * 
  1039.              * NB : The previous program was not satisfying. The first operation
  1040.              * was to transform the second parameter into a positive one. The
  1041.              * assignment "val2 = -val2" can be incorrect if the value is the
  1042.              * first integer (-2 ** 31) since 2**31 is not an integer.
  1043.              */
  1044.  
  1045.             POP(val2);
  1046.             POP(val1);
  1047.             if (val2 == 0)
  1048.                 raise(NUMERIC_ERROR, "Division by zero");
  1049.             else {
  1050.                 value = val1 % val2;
  1051.                 PUSH(value);
  1052.             }
  1053.             break;
  1054.  
  1055.         case I_REM_L:
  1056.             POPL(lval2);
  1057.             POPL(lval1);
  1058.             if (lval2 == 0)
  1059.                 raise(NUMERIC_ERROR, "Division by zero");
  1060.             else {
  1061.                 lvalue = lval1 % lval2;
  1062.                 PUSHL(lvalue);
  1063.             }
  1064.             break;
  1065.  
  1066.         case I_MOD_B:
  1067.         case I_MOD_W:
  1068.  
  1069.             /* Modulo Operation
  1070.              * ----------------
  1071.              * 
  1072.              * The idea of the modification is to reduce the complexity of the
  1073.              * calculation. The, modulo can be calculated quite easily if the
  1074.              * first parameter is positive. Therefore if the first parameter is
  1075.              * negative then we calculate the first positive number according
  1076.              * to the following equality:
  1077.               * a mod b = (a + n*b) mod b
  1078.              */
  1079.  
  1080.             POP(val2);
  1081.             POP(val1);
  1082.             if (val2 == 0)
  1083.                 raise(NUMERIC_ERROR, "Division by zero");
  1084.             else {
  1085.                 /* the idea is to transform val1 in a positive value.
  1086.                  * a mod b = (a + k*b) mod b
  1087.                  */
  1088.                 if ( (val1 <= 0) && ( val2 > 0)) {
  1089.                     /* val1 = (val1 + (1 - val1/val2)* val2  */
  1090.                     val1 = val1 - ((val1/val2) * val2) + val2; 
  1091.                 }
  1092.                 if ( (val1 <= 0) && ( val2 < 0)) {
  1093.                     /* val1 = (val1 + (-1 - val1/val2)* val2  */
  1094.                     val1 = (val1 - val2) - (val1/val2)*val2; 
  1095.                 }
  1096.                 if (val2 > 0)
  1097.                     value = val1 % val2;
  1098.                 else
  1099.                     value = (val2 + (val1 % val2)) % val2;
  1100.                 PUSH(value);
  1101.             }
  1102.             break;
  1103.  
  1104.         case I_MOD_L:
  1105.             POPL(lval2);
  1106.             POPL(lval1);
  1107.             if (lval2 == 0)
  1108.                 raise(NUMERIC_ERROR, "Division by zero");
  1109.             else {
  1110.                 /* the idea is to transform lval1 in a positive value.
  1111.                  * a mod b = (a + k*b) mod b
  1112.                  */
  1113.                 if ( (lval1 <= 0) && ( lval2 > 0)) {
  1114.                     /* lval1 = (lval1 + (1 - lval1/lval2)* lval2  */
  1115.                     lval1 = lval1 - ((lval1/lval2) * lval2) + lval2; 
  1116.                 }
  1117.                 if ( (lval1 <= 0) && ( lval2 < 0)) {
  1118.                     /* lval1 = (lval1 + (-1 - lval1/lval2)* lval2  */
  1119.                     lval1 = (lval1 - lval2) - (lval1/lval2)*lval2; 
  1120.                 }
  1121.                 if (lval2 > 0)
  1122.                     lvalue = lval1 % lval2;
  1123.                 else
  1124.                     lvalue = (lval2 + (lval1 % lval2)) % lval2;
  1125.                 PUSHL(lvalue);
  1126.             }
  1127.             break;
  1128.  
  1129.         case I_MUL_B:
  1130.             POP(val2);
  1131.             POP(val1);
  1132.             value = val1 * val2;
  1133.             if (value < -128 || value > 127)
  1134.                 raise(NUMERIC_ERROR, "Overflow");
  1135.             else
  1136.                 PUSH(value);
  1137.             break;
  1138.  
  1139.         case I_MUL_W:
  1140.             POP(val2);
  1141.             POP(val1);
  1142.             value = word_mul(val1, val2, &overflow);
  1143.             if (overflow)
  1144.                 raise(NUMERIC_ERROR, "Overflow");
  1145.             PUSH(value);
  1146.             break;
  1147.  
  1148.         case I_MUL_L:
  1149.             POPL(lval2);
  1150.             POPL(lval1);
  1151.             lvalue = long_mul(lval1, lval2, &overflow);
  1152.             if (overflow)
  1153.                 raise(NUMERIC_ERROR, "Overflow");
  1154.             PUSHL(lvalue);
  1155.             break;
  1156.  
  1157.         case I_POW_B:
  1158.             POP(val2);
  1159.             POP(val1);
  1160.             if (val2 < 0)
  1161.                 raise(NUMERIC_ERROR, "Overflow");
  1162.             else if (val2 == 0)
  1163.                 value = 1;
  1164.             else {
  1165.                 value = val1;
  1166.                 for (i = 1; i < val2; i++) {
  1167.                     value = value * val1;
  1168.                     if (value > 127)
  1169.                         raise(NUMERIC_ERROR, "Overflow");
  1170.                 }
  1171.             }
  1172.             PUSH(value);
  1173.             break;
  1174.  
  1175.         case I_POW_W:
  1176.             POP(val2);
  1177.             POP(val1);
  1178.             if (val2 < 0)
  1179.                 raise(NUMERIC_ERROR, "Overflow");
  1180.             else if (val2 == 0)
  1181.                 value = 1;
  1182.             else
  1183.                 value = val1;
  1184.             for (i = 1; i < val2; i++) {
  1185.                 value = word_mul(value, val1, &overflow);
  1186.                 if (overflow)
  1187.                     raise(NUMERIC_ERROR, "Overflow");
  1188.             }
  1189.             PUSH(value);
  1190.             break;
  1191.  
  1192.         case I_POW_L:
  1193.             POPL(lval2);
  1194.             POPL(lval1);
  1195.             if (lval2 < 0)
  1196.                 raise(NUMERIC_ERROR, "Overflow");
  1197.             else if (lval2 == 0)
  1198.                 lvalue = 1;
  1199.             else {
  1200.                 lvalue = lval1;
  1201.                 for (i = 1; i < lval2; i++) {
  1202.                     lvalue = long_mul(lvalue, lval1, &overflow);
  1203.                     if (overflow)
  1204.                         raise(NUMERIC_ERROR, "Overflow");
  1205.                 }
  1206.             }
  1207.             PUSHL(lvalue);
  1208.             break;
  1209.  
  1210.         case I_FIX_MUL:
  1211.             POP_ADDR(bas1, off1);/* type and value of op2 */
  1212.             ptr2 = ADDR(bas1, off1);
  1213.             POPL(fval2);
  1214.  
  1215.             POP_ADDR(bas1, off1);/* type and value of op1 */
  1216.             ptr1 = ADDR(bas1, off1);
  1217.             POPL(fval1);
  1218.  
  1219.             POP_ADDR(bas1, off1);/* result type */
  1220.             ptr = ADDR(bas1, off1);
  1221.  
  1222.             if (fval2 == 0 || fval1 == 0) {
  1223.                 fvalue = 0;
  1224.                 PUSHL(fvalue);
  1225.             }
  1226.             else {
  1227.                 to_type = TYPE(ptr);
  1228.                 if (to_type == TT_FX_RANGE) {
  1229.  
  1230.                     sgn  = SIGN(fval1);
  1231.                     fval1 = ABS(fval1);
  1232.                     sgn *= SIGN(fval2);
  1233.                     fval2 = ABS(fval2);
  1234.                     int_tom(fix_val1,fval1);
  1235.                     int_tom(fix_val2,fval2);
  1236.  
  1237.                     temp_template->small_exp_2 = FX_RANGE(ptr1)->small_exp_2 +
  1238.                       FX_RANGE(ptr2)->small_exp_2;
  1239.                     temp_template->small_exp_5 = FX_RANGE(ptr1)->small_exp_5 +
  1240.                       FX_RANGE(ptr2)->small_exp_5;
  1241.  
  1242.                     int_mul(fix_val1, fix_val2, fix_resu);
  1243.                     fix_convert(fix_resu, temp_template, FX_RANGE(ptr));
  1244.                     fvalue = int_tol(fix_resu);
  1245.                     if (arith_overflow)
  1246.                         raise(NUMERIC_ERROR,
  1247.                           "Fixed point multiplication overflow");
  1248.                     if (fix_out_of_bounds(fvalue, ptr))
  1249.                         raise(CONSTRAINT_ERROR,
  1250.                           "Fixed point value out of bounds");
  1251.                     PUSHL(sgn*fvalue);
  1252.                 }
  1253.                 else
  1254.                     raise(SYSTEM_ERROR, "Conversion to invalid type");
  1255.             }
  1256.             break;
  1257.  
  1258.         case I_FIX_DIV:
  1259.             POP_ADDR(bas1, off1);/* type and value of op2 */
  1260.             ptr2 = ADDR(bas1, off1);
  1261.             POPL(fval2);
  1262.  
  1263.             POP_ADDR(bas1, off1);/* type and value of op1 */
  1264.             ptr1 = ADDR(bas1, off1);
  1265.             POPL(fval1);
  1266.  
  1267.             POP_ADDR(bas1, off1);/* result type */
  1268.             ptr = ADDR(bas1, off1);
  1269.  
  1270.             if (fval2 == 0) {
  1271.                 raise(NUMERIC_ERROR, "Fixed point division by zero");
  1272.                 fvalue = 0;
  1273.                 PUSHL(fvalue);
  1274.             }
  1275.             else {
  1276.                 to_type = TYPE(ptr);
  1277.                 if (to_type == TT_FX_RANGE) {
  1278.  
  1279.                     sgn  = SIGN(fval1);
  1280.                     fval1 = ABS(fval1);
  1281.                     sgn *= SIGN(fval2);
  1282.                     fval2 = ABS(fval2);
  1283.                     int_tom(fix_val1,fval1);
  1284.                     int_tom(fix_val2,fval2);
  1285.  
  1286.                     temp_template->small_exp_2 = FX_RANGE(ptr)->small_exp_2 +
  1287.                       FX_RANGE(ptr2)->small_exp_2;
  1288.                     temp_template->small_exp_5 = FX_RANGE(ptr)->small_exp_5 +
  1289.                       FX_RANGE(ptr2)->small_exp_5;
  1290.  
  1291.                     fix_convert(fix_val1, FX_RANGE(ptr1), temp_template);
  1292.                     int_div(fix_val1, fix_val2, fix_resu);
  1293.                     fvalue = int_tol(fix_resu);
  1294.                     if (arith_overflow)
  1295.                         raise(NUMERIC_ERROR, "Fixed point division overflow");
  1296.                     if (fix_out_of_bounds(fvalue, ptr))
  1297.                         raise(CONSTRAINT_ERROR,
  1298.                           "Fixed point value out of bounds");
  1299.                     PUSHL(sgn*fvalue);
  1300.                 }
  1301.                 else
  1302.                     raise(SYSTEM_ERROR, "Conversion to invalid type");
  1303.             }
  1304.             break;
  1305.  
  1306.         case I_CONVERT_TO_L:
  1307.             GET_LAD(bse, off);
  1308.             convert(bse, off);
  1309.             break;
  1310.  
  1311.         case I_CONVERT_TO_G:
  1312.             GET_GAD(bse, off);
  1313.             convert(bse, off);
  1314.             break;
  1315.  
  1316.         case I_NEG_B:
  1317.             if (TOS == -128)
  1318.                 raise(NUMERIC_ERROR,"Byte overflow");
  1319.             else
  1320.                 TOS = -TOS;
  1321.             break;
  1322.  
  1323.         case I_NEG_W:
  1324.             if (TOS == MIN_INTEGER)
  1325.                 raise(NUMERIC_ERROR,"Overflow");
  1326.             else
  1327.                 TOS = -TOS;
  1328.             break;
  1329.  
  1330.         case I_NEG_L:
  1331.             if (TOS == MIN_LONG)
  1332.                 raise(NUMERIC_ERROR,"Overflow");
  1333.             else
  1334.                 TOSL = -TOSL;
  1335.             break;
  1336.  
  1337.         case I_ABS_B:
  1338.             if (TOS == -128)
  1339.                 raise(NUMERIC_ERROR,"Byte overflow");
  1340.             else
  1341.                 TOS = ABS(TOS);
  1342.             break;
  1343.  
  1344.         case I_ABS_W:
  1345.             if (TOS == MIN_INTEGER)
  1346.                 raise(NUMERIC_ERROR,"Overflow");
  1347.             else
  1348.                 TOS = ABS(TOS);
  1349.             break;
  1350.  
  1351.         case I_ABS_L:
  1352.             if (TOS == MIN_LONG)
  1353.                 raise(NUMERIC_ERROR,"Overflow");
  1354.             else
  1355.                 TOSL = ABS(TOSL);
  1356.             break;
  1357.  
  1358.         case I_NOT:
  1359.             TOS = 1 - TOS;
  1360.             break;
  1361.  
  1362.         case I_AND:
  1363.             POP(val2);
  1364.             POP(val1);
  1365.             value = (val1 & val2);
  1366.             PUSH(value);
  1367.             break;
  1368.  
  1369.         case I_XOR:
  1370.             POP(val2);
  1371.             POP(val1);
  1372.             value = (val1 ^ val2);
  1373.             PUSH(value);
  1374.             break;
  1375.  
  1376.         case I_OR:
  1377.             POP(val2);
  1378.             POP(val1);
  1379.             value = (val1 | val2);
  1380.             PUSH(value);
  1381.             break;
  1382.  
  1383.         case I_IS_EQUAL:
  1384.             TOS = (TOS == 1);
  1385.             break;
  1386.  
  1387.         case I_IS_GREATER:
  1388.             TOS = (TOS == 2);
  1389.             break;
  1390.  
  1391.         case I_IS_GREATER_OR_EQUAL:
  1392.             TOS = (TOS >= 1);
  1393.             break;
  1394.  
  1395.         case I_IS_LESS:
  1396.             TOS = (TOS == 0);
  1397.             break;
  1398.  
  1399.         case I_IS_LESS_OR_EQUAL:
  1400.             TOS = (TOS <= 1);
  1401.             break;
  1402.  
  1403.         case I_MEMBERSHIP:
  1404.             membership();
  1405.             break;
  1406.  
  1407.         case I_QUAL_RANGE_G:
  1408.             GET_GAD(bse, off);
  1409.             ptr1 = ADDR(bse, off);
  1410.             if (TYPE(ptr1) == TT_FX_RANGE) {
  1411.                 if (fix_out_of_bounds(TOSL, ptr1))
  1412.                     raise(CONSTRAINT_ERROR, "Fixed point value out of bounds");
  1413.             }
  1414.             else if (TYPE(ptr1) == TT_FL_RANGE) {
  1415.                 rval1 = FL_RANGE(ptr1)->fllow;
  1416.                 rval2 = FL_RANGE(ptr1)->flhigh;
  1417.                 if (TOSF < rval1 || TOSF > rval2)
  1418.                     raise(CONSTRAINT_ERROR,
  1419.                       "Floating point value out of bounds");
  1420.             }
  1421.             else if ((TYPE(ptr1) == TT_I_RANGE) ||
  1422.                 (TYPE(ptr1) == TT_E_RANGE) ||
  1423.                 (TYPE(ptr1) == TT_ENUM)) {
  1424.                 val_low = I_RANGE(ptr1)->ilow;
  1425.                 val_high = I_RANGE(ptr1)->ihigh;
  1426.                 if (TOS < val_low || TOS > val_high)
  1427.                     raise(CONSTRAINT_ERROR, "Out of bounds");
  1428.             }
  1429. #ifdef LONG_INT
  1430.             else if (TYPE(ptr1) == TT_L_RANGE) {
  1431.                 lvalue = TOSL;
  1432.                 lval_low = L_RANGE(ptr1)->llow;
  1433.                 lval_high = L_RANGE(ptr1)->lhigh;
  1434.                 if (lvalue < lval_low || lvalue > lval_high)
  1435.                     raise (CONSTRAINT_ERROR, "Out of bounds");
  1436.             }
  1437. #endif
  1438.             else    /* error here */
  1439.                 ;
  1440.             break;
  1441.  
  1442.         case I_QUAL_RANGE_L:
  1443.             GET_LAD(bse, off);
  1444.             ptr1 = ADDR(bse, off);
  1445.             if (TYPE(ptr1) == TT_FX_RANGE) {
  1446.                 fval1 = TOSL;
  1447.                 if (fix_out_of_bounds(fval1, ptr1))
  1448.                     raise(CONSTRAINT_ERROR, "Fixed point value out of bounds");
  1449.             }
  1450.             else if (TYPE(ptr1) == TT_FL_RANGE) {
  1451.                 rvalue = TOSF;
  1452.                 rval1 = FL_RANGE(ptr1)->fllow;
  1453.                 rval2 = FL_RANGE(ptr1)->flhigh;
  1454.                 if (rvalue < rval1 || rvalue > rval2)
  1455.                     raise(CONSTRAINT_ERROR,
  1456.                       "Floating point value out of bounds");
  1457.             }
  1458.             else if ((TYPE(ptr1) == TT_I_RANGE) ||
  1459.                 (TYPE(ptr1) == TT_E_RANGE) ||
  1460.                 (TYPE(ptr1) == TT_ENUM)) {
  1461.                 val_low = I_RANGE(ptr1)->ilow;
  1462.                 val_high = I_RANGE(ptr1)->ihigh;
  1463.                 if (TOS < val_low || TOS > val_high)
  1464.                     raise(CONSTRAINT_ERROR, "Out of bounds");
  1465.             }
  1466. #ifdef LONG_INT
  1467.             else if (TYPE(ptr1) == TT_L_RANGE) {
  1468.                 lvalue = TOSL;
  1469.                 lval_low = L_RANGE(ptr1)->llow;
  1470.                 lval_high = L_RANGE(ptr1)->lhigh;
  1471.                 if (lvalue < lval_low || lvalue > lval_high)
  1472.                     raise (CONSTRAINT_ERROR, "Out of bounds");
  1473.             }
  1474. #endif
  1475.             else    /* error here */
  1476.                 ;
  1477.             break;
  1478.  
  1479.         case I_QUAL_DISCR_G:
  1480.             GET_GAD(bse, off);
  1481.             qual_discr(bse, off);
  1482.             break;
  1483.  
  1484.         case I_QUAL_DISCR_L:
  1485.             GET_LAD(bse, off);
  1486.             qual_discr(bse, off);
  1487.             break;
  1488.  
  1489.         case I_QUAL_INDEX_G:
  1490.             GET_GAD(bse, off);
  1491.             ptr = ADDR(bse, off);
  1492.             POP_ADDR(bse, off);
  1493.             PUSH_ADDR(bse, off);
  1494.             ptr1 = ADDR(bse, off);
  1495.             if (!qual_index(ptr, ptr1))
  1496.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1497.             break;
  1498.  
  1499.         case I_QUAL_INDEX_L:
  1500.             GET_LAD(bse, off);
  1501.             ptr = ADDR(bse, off);
  1502.             POP_ADDR(bse, off);
  1503.             PUSH_ADDR(bse, off);
  1504.             ptr1 = ADDR(bse, off);
  1505.             if (!qual_index(ptr, ptr1))
  1506.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1507.             break;
  1508.  
  1509.         case I_QUAL_SUB_G:
  1510.             GET_GAD(bse, off);
  1511.             ptr = ADDR(bse, off);
  1512.             POP_ADDR(bse, off);
  1513.             PUSH_ADDR(bse, off);
  1514.             ptr1 = ADDR(bse, off);
  1515.             if (!qual_sub(ptr, ptr1))
  1516.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1517.             break;
  1518.  
  1519.         case I_QUAL_SUB_L:
  1520.             GET_LAD(bse, off);
  1521.             ptr = ADDR(bse, off);
  1522.             POP_ADDR(bse, off);
  1523.             PUSH_ADDR(bse, off);
  1524.             ptr1 = ADDR(bse, off);
  1525.             if (!qual_sub(ptr, ptr1))
  1526.                 raise(CONSTRAINT_ERROR, "Wrong bounds");
  1527.             break;
  1528.  
  1529.         case I_SUB_B:
  1530.             POP(val2);
  1531.             POP(val1);
  1532.             value = val1 - val2;
  1533.             if (value < -128 || value > 127)
  1534.                 raise(NUMERIC_ERROR, "Overflow");
  1535.             else
  1536.                 PUSH(value);
  1537.             break;
  1538.  
  1539.         case I_SUB_W:
  1540.             POP(val2);
  1541.             POP(val1);
  1542.             value = word_sub(val1, val2, &overflow);
  1543.             if (overflow)
  1544.                 raise(NUMERIC_ERROR, "Overflow");
  1545.             else
  1546.                 PUSH(value);
  1547.             break;
  1548.  
  1549.         case I_SUB_L:
  1550.             POPL(lval2);
  1551.             POPL(lval1);
  1552.             lvalue = long_sub(lval1, lval2, &overflow);
  1553.             if (overflow)
  1554.                 raise(NUMERIC_ERROR, "Overflow");
  1555.             else
  1556.                 PUSHL(lvalue);
  1557.             break;
  1558.  
  1559.             /* Array Instructions */
  1560.  
  1561.         case I_ARRAY_CATENATE:
  1562.             array_catenate();
  1563.             break;
  1564.  
  1565.         case I_ARRAY_MOVE:
  1566.             array_move();
  1567.             break;
  1568.  
  1569.         case I_ARRAY_SLICE:
  1570.             array_slice();
  1571.             break;
  1572.  
  1573.         case I_ARRAY_AND:
  1574.             POP_ADDR(bas1, off1);/* right type */
  1575.             POP_ADDR(bas2, off2);/* right object */
  1576.             POP_ADDR(bse, off);/* left type */
  1577.             value = SIZE(ADDR(bse, off));
  1578.             if (SIZE(ADDR(bas1, off1)) != value)
  1579.                 raise(CONSTRAINT_ERROR, "Arrays not same size for AND");
  1580.             else {
  1581.                 POP_ADDR(bas1, off1);/* left object */
  1582.                 ptr1 = ADDR(bas1, off1);
  1583.                 ptr2 = ADDR(bas2, off2);
  1584.                 create(value, &bas1, &off1, &ptr);
  1585.                 for (i = 0; i <= value - 1; i++)
  1586.                     *ptr++ = (*ptr1++ & *ptr2++);
  1587.                 PUSH_ADDR(bas1, off1);/* result object */
  1588.                 PUSH_ADDR(bse, off);/* result type */
  1589.             }
  1590.             break;
  1591.  
  1592.         case I_ARRAY_OR:
  1593.             POP_ADDR(bas1, off1);/* right type */
  1594.             POP_ADDR(bas2, off2);/* right object */
  1595.             POP_ADDR(bse, off);/* left type */
  1596.             value = SIZE(ADDR(bse, off));
  1597.             if (SIZE(ADDR(bas1, off1)) != value)
  1598.                 raise(CONSTRAINT_ERROR, "Arrays not same size for OR");
  1599.             else {
  1600.                 POP_ADDR(bas1, off1);/* left object */
  1601.                 ptr1 = ADDR(bas1, off1);
  1602.                 ptr2 = ADDR(bas2, off2);
  1603.                 create(value, &bas1, &off1, &ptr);
  1604.                 for (i = 0; i <= value - 1; i++)
  1605.                     *ptr++ = (*ptr1++ | *ptr2++);
  1606.                 PUSH_ADDR(bas1, off1);/* result object */
  1607.                 PUSH_ADDR(bse, off);/* result type */
  1608.             }
  1609.             break;
  1610.  
  1611.         case I_ARRAY_XOR:
  1612.             POP_ADDR(bas1, off1);/* right type */
  1613.             POP_ADDR(bas2, off2);/* right object */
  1614.             POP_ADDR(bse, off);/* left type */
  1615.             value = SIZE(ADDR(bse, off));
  1616.             if (SIZE(ADDR(bas1, off1)) != value)
  1617.                 raise(CONSTRAINT_ERROR, "Arrays not same size for XOR");
  1618.             else {
  1619.                 POP_ADDR(bas1, off1);/* left object */
  1620.                 ptr1 = ADDR(bas1, off1);
  1621.                 ptr2 = ADDR(bas2, off2);
  1622.                 create(value, &bas1, &off1, &ptr);
  1623.                 for (i = 0; i <= value - 1; i++) {
  1624.                     *ptr++ = (*ptr1++ ^ *ptr2++);
  1625.                 }
  1626.                 PUSH_ADDR(bas1, off1);/* result object */
  1627.                 PUSH_ADDR(bse, off);/* result type */
  1628.             }
  1629.             break;
  1630.  
  1631.         case I_ARRAY_NOT:
  1632.             POP_ADDR(bse, off);/* type */
  1633.             value = SIZE(ADDR(bse, off));
  1634.             POP_ADDR(bas1, off1);/* object */
  1635.             ptr1 = ADDR(bas1, off1);
  1636.             create(value, &bas1, &off1, &ptr);
  1637.             for (i = 0; i <= value - 1; i++)
  1638.                 *ptr++ = (1 - *ptr1++);
  1639.             PUSH_ADDR(bas1, off1);/* result object */
  1640.             PUSH_ADDR(bse, off);/* result type */
  1641.             break;
  1642.  
  1643.             /* Record Instructions */
  1644.  
  1645.         case I_RECORD_MOVE_G:
  1646.             GET_GAD(bse, off);
  1647.             ptr = ADDR(bse, off);
  1648.             POP_ADDR(bas1, off1);/* value */
  1649.             ptr1 = ADDR(bas1, off1);
  1650.             POP_ADDR(bas2, off2);/* object */
  1651.             ptr2 = ADDR(bas2, off2);
  1652.             record_move(ptr2, ptr1, ptr);
  1653.             break;
  1654.  
  1655.         case I_RECORD_MOVE_L:
  1656.             GET_LAD(bse, off);
  1657.             ptr = ADDR(bse, off);
  1658.             POP_ADDR(bas1, off1);/* value */
  1659.             ptr1 = ADDR(bas1, off1);
  1660.             POP_ADDR(bas2, off2);/* object */
  1661.             ptr2 = ADDR(bas2, off2);
  1662.             record_move(ptr2, ptr1, ptr);
  1663.             break;
  1664.  
  1665.             /* Attributes */
  1666.  
  1667.         case I_ATTRIBUTE:
  1668.             attribute = GET_BYTE;
  1669.             /* So that all reads from code segment are done in this
  1670.              * procedure, we retrieve the dim argument used for
  1671.              * some attributes
  1672.              */
  1673.             if (attribute==ATTR_O_FIRST || attribute==ATTR_O_LAST
  1674.               || attribute == ATTR_O_LENGTH || attribute==ATTR_O_RANGE)
  1675.                 value = GET_WORD;
  1676.             else
  1677.                 value = 0;
  1678.             main_attr(attribute,value);
  1679.             break;
  1680.  
  1681.             /* Control Instructions */
  1682.  
  1683.         case I_ENTER_BLOCK:
  1684. #ifdef DEBUG_TASKING
  1685.             if (tasking_trace)
  1686.                 printf("enter block pushing %d for previous\n",bfp);
  1687. #endif
  1688.             PUSH(bfp);    /* save previous BFP */
  1689.             bfp = cur_stackptr;
  1690. #ifdef DEBUG_TASKING
  1691.             if (tasking_trace)
  1692.                 printf("enter block bfp %d\n",bfp);
  1693. #endif
  1694.             PUSHP(0L);    /* data_link */
  1695.             PUSHP(0L);        /* tasks_declared */
  1696.             PUSH(1);    /* num noterm */
  1697.             PUSH(1);    /* num deps */
  1698.             PUSH(NULL_TASK);/* subtasks */
  1699.             PUSH(0);    /* exception vector */
  1700.             break;
  1701.  
  1702.         case I_EXIT_BLOCK:
  1703. #ifdef DEBUG_TASKING
  1704.             if (tasking_trace) {
  1705. #ifdef IBM_PC
  1706.                 printf("exit block bfp %d %p\n",bfp,cur_stack+bfp);
  1707. #else
  1708.                 printf("exit block bfp %d %ld\n",bfp,cur_stack+bfp);
  1709. #endif
  1710.             }
  1711. #endif
  1712.             if (BLOCK_FRAME->bf_num_deps >= 1) {
  1713.                 --ip;    /* to reexecute the 'leave_block' */
  1714.                 complete_block();
  1715.             }
  1716.             else {
  1717.                 deallocate(BLOCK_FRAME->bf_data_link);
  1718.                 sp = BLOCK_FRAME->bf_previous_bfp;
  1719.                 if ((tfptr1 = BLOCK_FRAME->bf_tasks_declared) != 0) {
  1720.                     bfptr = (struct bf *)(&cur_stack[sp]);
  1721.                     tfptr2 = bfptr->bf_tasks_declared;
  1722.                     if (tfptr2 != 0) {
  1723.                         value = pop_task_frame();
  1724.                         *tfptr2 = union_tasks_declared(value, *tfptr2);
  1725.                     }
  1726.                     else    /* put task frame on previous bfp */
  1727.                         bfptr->bf_tasks_declared = tfptr1;
  1728.                 }
  1729.                 cur_stackptr = bfp - 1;
  1730.                 bfp = sp;
  1731. #ifdef DEBUG_TASKING
  1732.                 if (tasking_trace)
  1733.                     printf("exit block setting bfp %d\n",bfp);
  1734. #endif
  1735.             }
  1736.             break;
  1737.  
  1738.         case I_LEAVE_BLOCK:
  1739. #ifdef DEBUG_TASKING
  1740.             if (tasking_trace) {
  1741. #ifdef IBM_PC
  1742.                 printf("leave block bfp %d %p\n",bfp,cur_stack+bfp);
  1743. #else
  1744.                 printf("leave block bfp %d %ld\n",bfp,cur_stack+bfp);
  1745. #endif
  1746.             }
  1747. #endif
  1748.             if (BLOCK_FRAME->bf_num_deps >= 1) {
  1749.                 --ip;    /* to reexecute the 'leave_block' */
  1750.                 complete_block();
  1751.             }
  1752.             else {
  1753.                 deallocate(BLOCK_FRAME->bf_data_link);
  1754.                 sp = BLOCK_FRAME->bf_previous_bfp;
  1755.                 if ((tfptr1 = BLOCK_FRAME->bf_tasks_declared) != 0) {
  1756.                     bfptr = (struct bf *)(&cur_stack[sp]);
  1757.                     tfptr2 = bfptr->bf_tasks_declared;
  1758.                     if (tfptr2 != 0) {
  1759.                         value = pop_task_frame();
  1760.                         *tfptr2 = union_tasks_declared(value, *tfptr2);
  1761.                     }
  1762.                     else    /* put task frame on previous bfp */
  1763.                         bfptr->bf_tasks_declared = tfptr1;
  1764.                 }
  1765.                 if (sp < sfp) {/* return to previous stack_frame */
  1766.                     cur_stackptr = sfp - 1;/* get rid of the relay set */
  1767.                     /* in case an exception is propagated, ip */
  1768.                     /* must point again to the default handler */
  1769. #ifdef ALIGN_WORD
  1770.                     val2 = get_int((int *)(cur_code + code_seglen[cs] 
  1771.                       - sizeof(int) - 1));
  1772. #else
  1773.                     val2 = *(int *)(cur_code+code_seglen[cs] - sizeof(int) - 1);
  1774. #endif
  1775.                     /* length of local variables */
  1776.                     if (ip < 2) {
  1777.                         --cur_stackptr;/* to discard it */
  1778. #ifdef TRACE
  1779.                         if (call_trace)
  1780.                             printf("abandoning %s\n", code_slots[cs]);
  1781. #endif
  1782.                     }
  1783.                     else {
  1784.                         POP(ip);
  1785. #ifdef TRACE
  1786.                         if (call_trace) {
  1787.                             if (code_slots[cs])
  1788.                                 printf("returning from %s (tos %d)\n",
  1789.                                   code_slots[cs],cur_stackptr- 3-val2);
  1790.                             else 
  1791.                                 printf("returning from %s (tos %d)\n", 
  1792.                                   "compiler_generated_procedure",
  1793.                                   cur_stackptr-3-val2);
  1794.                         }
  1795. #endif
  1796.                     }
  1797.                     POP(lin);
  1798.                     POP(cs);
  1799.                     cur_code = code_segments[cs];
  1800.                     POP(sfp);
  1801.                     cur_stackptr -= val2;/* to get rid of it */
  1802.                 }
  1803.                 else
  1804.                     cur_stackptr = bfp - 1;
  1805.                 bfp = sp;
  1806. #ifdef DEBUG_TASKING
  1807.                 if (tasking_trace)
  1808.                     printf("leave block setting bfp %d\n",bfp);
  1809. #endif
  1810.             }
  1811.             break;
  1812.  
  1813.         case I_CALL_L:
  1814.             GET_LAD(bse, off);/* addr of proc. object */
  1815.             ptr = ADDR(bse, off);
  1816.             value = *ptr;
  1817.             if (value < 0)
  1818.                 raise(PROGRAM_ERROR, "Access before elaboration");
  1819.             else {
  1820.                 if (cur_stackptr+SECURITY_LEVEL>new_task_size)
  1821.                     raise(STORAGE_ERROR, "Stack overflow");
  1822.                 else {
  1823.                     old_cs = cs;
  1824.                     cs = value;
  1825. #ifdef TRACE
  1826.                     if (call_trace) {
  1827.                         if (code_slots[cs])
  1828.                             printf("calling %s (tos %d -> ",
  1829.                               code_slots[cs],cur_stackptr);
  1830.                         else 
  1831.                             printf("calling %s (tos %d -> ",
  1832.                               "compiler_generated_procedure", cur_stackptr);
  1833.                     }
  1834. #endif
  1835.                     cur_code = code_segments[cs];
  1836. #ifdef ALIGN_WORD
  1837.                     val1 = get_int((int *)(cur_code + code_seglen[cs] 
  1838.                       - sizeof(int) - 1));
  1839. #else
  1840.                     val1 = *(int *)(cur_code+code_seglen[cs] - sizeof(int) - 1);
  1841. #endif
  1842.                     /* reserve space for locals */
  1843.                     if (val1 < 0)
  1844.                         raise(SYSTEM_ERROR, "Negative size of locals");
  1845.                     else
  1846.                         cur_stackptr += val1;
  1847.                     PUSH(sfp);
  1848.                     PUSH(old_cs);
  1849.                     PUSH(lin);
  1850.                     PUSH(ip);
  1851.                     sfp = cur_stackptr + 1;
  1852.                     ip = 2;
  1853.                     val2 = *(++ptr) * 2;/* length of relay set */
  1854.                     for (i = 1; i <= val2; i++)            /* copy relay set */
  1855.                         PUSH(*++ptr);
  1856. #ifdef TRACE
  1857.                     if(call_trace)
  1858.                         printf("%d)\n",cur_stackptr);
  1859. #endif
  1860.                 }
  1861.             }
  1862.             break;
  1863.  
  1864.         case I_CALL_G:
  1865.             GET_GAD(bse, off);/* addr of proc. object */
  1866.             ptr = ADDR(bse, off);
  1867.             value = *ptr;
  1868.             if (value < 0)
  1869.                 raise(PROGRAM_ERROR, "Access before elaboration");
  1870.             else {
  1871.                 if (cur_stackptr+SECURITY_LEVEL>new_task_size)
  1872.                     raise(STORAGE_ERROR, "Stack overflow");
  1873.                 else {
  1874.                     old_cs = cs;
  1875.                     cs = value;
  1876. #ifdef TRACE
  1877.                     if (call_trace) {
  1878.                         if (code_slots[cs])
  1879.                             printf("calling %s (tos %d -> ",
  1880.                               code_slots[cs],cur_stackptr);
  1881.                         else 
  1882.                             printf("calling %s (tos %d -> ",
  1883.                               "compiler_generated_procedure", cur_stackptr);
  1884.                     }
  1885. #endif
  1886.                     cur_code = code_segments[cs];
  1887.                     /* reserve space for local variables */
  1888. #ifdef ALIGN_WORD
  1889.                     val1 = get_int((int *)(cur_code + code_seglen[cs] 
  1890.                       - sizeof(int) - 1));
  1891. #else
  1892.                     val1 = *(int *)(cur_code+code_seglen[cs] - sizeof(int) - 1);
  1893. #endif
  1894.                     /* reserve space for locals */
  1895.                     if (val1 < 0)
  1896.                         raise(SYSTEM_ERROR, "Negative size of locals");
  1897.                     else
  1898.                         cur_stackptr += val1;
  1899.                     PUSH(sfp);
  1900.                     PUSH(old_cs);
  1901.                     PUSH(lin);
  1902.                     PUSH(ip);
  1903.                     sfp = cur_stackptr + 1;
  1904.                     ip = 2;
  1905.                     /* copy relay set */
  1906.                     val2 = *(++ptr) * 2;/* length of relay set */
  1907.                     for (i = 1; i <= val2; i++)            /* copy relay set */
  1908.                         PUSH(*++ptr);
  1909. #ifdef TRACE
  1910.                     if(call_trace)
  1911.                         printf("%d)\n",cur_stackptr);
  1912. #endif
  1913.                 }
  1914.             }
  1915.             break;
  1916.  
  1917.         case I_CALL_PREDEF:
  1918.             operation = GET_BYTE;
  1919.             predef();
  1920.             break;
  1921.  
  1922. #ifdef INTERFACE
  1923.         case I_CALL_INTERFACE: 
  1924.             interface(GET_WORD);
  1925.             break;
  1926. #endif
  1927.  
  1928.         case I_CASE_B:
  1929.         case I_CASE_W:
  1930.         case I_CASE_L:
  1931.             POP(value);
  1932.             nb = GET_WORD;
  1933.             jump = GET_WORD;
  1934.             for (i = 1; i <= nb; i++) {
  1935.                 val_high = GET_WORD;
  1936.                 if (value < val_high)
  1937.                     break;
  1938.                 jump = GET_WORD;
  1939.             }
  1940.             ip = jump;
  1941.             break;
  1942.  
  1943.         case I_RETURN_B:
  1944.         case I_RETURN_W:
  1945.             POP(value);
  1946.             cur_stack[sfp + GET_WORD] = value;
  1947.             break;
  1948.  
  1949.         case I_RETURN_L:
  1950.             POPL(lvalue);
  1951.             *(LONG(&cur_stack[sfp + GET_WORD])) = lvalue;
  1952.             break;
  1953.  
  1954.         case I_RETURN_A:
  1955.             POP_ADDR(bse, off);
  1956.             sp = GET_WORD + sfp;
  1957.             cur_stack[sp] = bse;
  1958.             cur_stack[sp + 1] = off;
  1959.             break;
  1960.  
  1961.         case I_RETURN_STRUC:
  1962.             sp = GET_WORD + sfp;
  1963.             POP_ADDR(bse, off);/*     type */
  1964.             ptr = ADDR(bse, off);
  1965.             POP_ADDR(bas2, off2);/* value */
  1966.             ptr2 = ADDR(bas2, off2);
  1967.  
  1968.             val1 = TYPE(ptr);/* type of type */
  1969.             val2 = SIZE(ptr);
  1970.             allocate(val2, &bas1, &off1, &ptr1);
  1971.             cur_stack[sp] = bas1;
  1972.             cur_stack[sp + 1] = off1;
  1973.  
  1974.             for (i = 0; i < val2; i++)
  1975.                 *ptr1++ = *ptr2++;
  1976.  
  1977.             switch(val1) {
  1978.             case TT_U_ARRAY:
  1979.             case TT_C_ARRAY:
  1980.             case TT_S_ARRAY:
  1981.             case TT_D_ARRAY:
  1982.                 if (bse >= heap_base) {/* non static template */
  1983.                     /* create new type template */
  1984.                     /* size of template */
  1985.                     val2 = *(ptr -  WORDS_HDR) - WORDS_HDR;
  1986.                     allocate(val2, &bse, &off, &ptr1);
  1987.  
  1988.                     for (i = 0; i < val2; i++)
  1989.                         *ptr1++ = *ptr++;
  1990.                 }
  1991.                 cur_stack[sp + 2] = bse;
  1992.                 cur_stack[sp + 3] = off;
  1993.                 break;
  1994.  
  1995.             case TT_RECORD:
  1996.             case TT_U_RECORD:
  1997.             case TT_C_RECORD:
  1998.             case TT_D_RECORD:
  1999.             case TT_V_RECORD:
  2000.                 break;
  2001.             }
  2002.             break;
  2003.  
  2004.         case I_END_FOR_LOOP_B:
  2005.         case I_END_FOR_LOOP_W:
  2006.         case I_END_FOR_LOOP_L:
  2007.             val2 = GET_WORD;
  2008.             off = TOS;
  2009.             bse = TOSM(1);
  2010.             lim = TOSM(2);
  2011.             value = *ADDR(bse, off);
  2012.             if (value >= lim) {
  2013.                 POP_ADDR(bse, off);
  2014.                 POP(val1);
  2015.             }
  2016.             else {
  2017.                 *ADDR(bse, off) = value + 1;
  2018.                 ip = val2;
  2019.             }
  2020.             break;
  2021.  
  2022.         case I_END_FORREV_LOOP_B:
  2023.         case I_END_FORREV_LOOP_W:
  2024.         case I_END_FORREV_LOOP_L:
  2025.             val2 = GET_WORD;
  2026.             off = TOS;
  2027.             bse = TOSM(1);
  2028.             lim = TOSM(2);
  2029.             value = *ADDR(bse, off);
  2030.             if (value <= lim) {
  2031.                 POP_ADDR(bse, off);
  2032.                 POP(val1);
  2033.             }
  2034.             else {
  2035.                 *ADDR(bse, off) = value - 1;
  2036.                 ip = val2;
  2037.             }
  2038.             break;
  2039.  
  2040.         case I_JUMP:
  2041.             val2 = GET_WORD;
  2042.             ip = val2;
  2043.             break;
  2044.  
  2045.         case I_JUMP_IF_FALSE:
  2046.             val2 = GET_WORD;
  2047.             POP(value);
  2048.             if (BOOL(value) == 0)
  2049.                 ip = val2;
  2050.             break;
  2051.  
  2052.         case I_JUMP_IF_TRUE:
  2053.             val2 = GET_WORD;
  2054.             POP(value);
  2055.             if (BOOL(value) == 1)
  2056.                 ip = val2;
  2057.             break;
  2058.  
  2059.         case I_JUMP_IF_GREATER:
  2060.             val2 = GET_WORD;
  2061.             POP(value);
  2062.             if (value == 2)
  2063.                 ip = val2;
  2064.             break;
  2065.  
  2066.         case I_JUMP_IF_GREATER_OR_EQUAL:
  2067.             val2 = GET_WORD;
  2068.             POP(value);
  2069.             if (value >= 1)
  2070.                 ip = val2;
  2071.             break;
  2072.  
  2073.         case I_JUMP_IF_LESS:
  2074.             val2 = GET_WORD;
  2075.             POP(value);
  2076.             if (value == 0)
  2077.                 ip = val2;
  2078.             break;
  2079.  
  2080.         case I_JUMP_IF_LESS_OR_EQUAL:
  2081.             val2 = GET_WORD;
  2082.             POP(value);
  2083.             if (value <= 1)
  2084.                 ip = val2;
  2085.             break;
  2086.  
  2087.             /* Miscellanous Instructions */
  2088.  
  2089.         case I_LOAD_EXCEPTION_REGISTER:
  2090.             exr = GET_WORD;
  2091.             raise_cs = cs;
  2092.             raise_lin = lin;
  2093.             raise_reason = "Instruction";
  2094.             break;
  2095.  
  2096.         case I_INSTALL_HANDLER:
  2097.             BLOCK_FRAME->bf_handler = GET_WORD;
  2098.             break;
  2099.  
  2100.         case I_RAISE:
  2101.             raise(exr, "");
  2102.             break;
  2103.  
  2104.         case I_RESTORE_STACK_POINTER:
  2105.             sp = GET_WORD + sfp;
  2106.             sp = cur_stack[sp];
  2107.             cur_stackptr = sp;
  2108.             break;
  2109.  
  2110.         case I_SAVE_STACK_POINTER:
  2111.             sp = GET_WORD + sfp;
  2112.             cur_stack[sp] = cur_stackptr;
  2113.             break;
  2114.  
  2115.         case I_STMT:
  2116.             lin = GET_WORD;
  2117. #ifdef TRACE
  2118.             if (line_trace)
  2119.                 printf("at line %d (tos %d)\n",lin,cur_stackptr);
  2120. #endif
  2121.             break;
  2122.  
  2123.         case I_SUBSCRIPT:
  2124.             subscript();
  2125.             break;
  2126.  
  2127.         case I_SELECT:
  2128.             value = GET_WORD; /* retrieve parameter for select */
  2129.             rselect(value);
  2130.             break;
  2131.  
  2132.         case I_TEST_EXCEPTION_REGISTER:
  2133.             PUSH(exr == GET_WORD);
  2134.             break;
  2135.  
  2136.         case I_TYPE_LOCAL:
  2137.             GET_GAD(bse, off);
  2138.             type_elaborate(1,bse,off);
  2139.             break;
  2140.  
  2141.         case I_TYPE_GLOBAL:
  2142.             GET_GAD(bse, off);
  2143.             type_elaborate(0,bse,off);
  2144.             break;
  2145.  
  2146.         case I_SUBPROGRAM:
  2147.             GET_LAD(bse,off);
  2148.             subprogram(bse,off);
  2149.             break;
  2150.  
  2151.         case I_CHECK_REC_SUBTYPE:
  2152.             POP_ADDR(bse, off);
  2153.             check_subtype_with_discr (ADDR (bse, off), NULL_INT);
  2154.             break;
  2155.  
  2156.         default:
  2157.             raise(SYSTEM_ERROR, "Bad opcode");
  2158.  
  2159.         }            /* end switch on operation code */
  2160.     }                /* end loop through instructions */
  2161. }                    /* end main_loop procedure */
  2162.  
  2163. #ifdef DEBUG_INT
  2164. static int get_word()            /*;get_word*/
  2165. {
  2166.     int     w;
  2167.     w = *((int *)(cur_code + ip));
  2168.     ip += sizeof(int);
  2169.     return w;
  2170. }
  2171.  
  2172. #endif
  2173. #ifdef ALIGN_WORD
  2174. int get_int(int *n)                                        /*;get_int*/
  2175. {
  2176.     register int i;
  2177.     int v;
  2178.     register char *sp,*tp;
  2179.  
  2180.     sp = (char *) n;
  2181.     tp = (char *) &v;
  2182.     for (i=0; i<sizeof(int); i++) *tp++ = *sp++;
  2183.     return v;
  2184. }
  2185.  
  2186. long get_long(long *n)                                /*;get_long*/
  2187. {
  2188.     register int i;
  2189.     long v;
  2190.     register char *sp,*tp;
  2191.  
  2192.     sp = (char *) n;
  2193.     tp = (char *) &v;
  2194.     for (i=0; i<sizeof(long); i++) *tp++ = *sp++;
  2195.     return v;
  2196. }
  2197.  
  2198. static int get_word()                                    /*;get_word*/
  2199. {
  2200.     /* if integers must be aligned, get byte by byte */
  2201.     int w,i;
  2202.     char *sp,*tp;
  2203.     sp = (char *) ((int *)(cur_code+ip));
  2204.     ip += sizeof(int);
  2205.     tp = (char *) &w;
  2206.     for (i=0; i<sizeof(int); i++)
  2207.         *tp++ = *sp++;
  2208.     return w;
  2209. }
  2210. #endif
  2211.  
  2212. int allocate_new_heap()                                /*;allocate_new_heap*/
  2213. {
  2214.     /* This procedure attempts to allocate a new heap.
  2215.      * It returns 1 if it succeeds, 0 otherwise.
  2216.      * The size of the heap is defined by max_mem (see config.h).
  2217.      */
  2218.  
  2219.     char *temporary;
  2220.  
  2221.     /* First tries to reallocate data_segments.  */
  2222.     temporary = realloc(data_segments,
  2223.       (data_segments_dim + 2) * sizeof(char **));
  2224.     if(temporary == (char *)0) return 0;
  2225.     data_segments = (int **)temporary;
  2226.  
  2227.     /* Now tries to allocate the new heap. */
  2228.     temporary = malloc((unsigned) max_mem * sizeof(int));
  2229.     if(temporary == (char *)0) return 0;
  2230.  
  2231.     /* Everything ok: increment data_segments_dim and set heap_base,
  2232.      * heap_addr and heap_next.
  2233.      */
  2234.     heap_addr = (int *)temporary;
  2235.     heap_base = ++data_segments_dim;
  2236.     data_segments[heap_base] = heap_addr;
  2237.     heap_next = heap_addr;
  2238. #ifdef DEBUG_STORES
  2239.     heap_store_addr = heap_addr;
  2240. #endif
  2241.     return 1;
  2242. }
  2243.  
  2244. #ifdef DEBUG_INT
  2245. static void zbreak(int before)                                        /*;zbreak*/
  2246. {
  2247.     break_point = before;
  2248. }
  2249. #endif
  2250.